#lang scheme
;GNU  Klub RFID door control program  
;  Copyright  (C) 2009,  hepek
;  (http://gnu.elfak.ni.ac.yu) gnuklub [at] gmail [dot] com
;  
;  This program is free software: you can redistribute it and/or modify
;  it under the terms of the GNU General Public License as published by
;  the Free Software Foundation, either version 3 of the License, or
;  (at your option) any later version.
;
;  This program is distributed in the hope that it will be useful,
;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;  GNU General Public License for more details.
;  
;  You should have received a copy of the GNU General Public License
;  along with this program.  If not, see <http://www.gnu.org/licenses/>.


;   ;;; ;;; ;;;          ;;;                                              
;   ;;; ;;  ;;;          ;;;                                              
;   ;;; ;;; ;;;;;;    ;;;;;;   ;;;;;    ;;;;;   ;;;;;      ;;;;    ;;;;;  
;   ;;; ;;; ;;;;;;;  ;;;;;;;  ;;;;;;;  ;;;;;;;  ;;;;;     ;; ;;;  ;;;;;;; 
;   ;;; ;;; ;;;  ;;  ;;  ;;;  ;;   ;;  ;;   ;;  ;;;       ;;;     ;;   ;; 
;   ;;; ;;; ;;;  ;; ;;;  ;;;  ;;   ;;  ;;   ;;  ;;;       ;;;;;;  ;;   ;; 
;   ;;; ;;; ;;;  ;;  ;;  ;;;  ;;   ;;  ;;   ;;  ;;;   ;;      ;;; ;;   ;; 
;   ;;; ;;; ;;;;;;;  ;;;;;;;  ;;;;;;;  ;;;;;;;  ;;;   ;;; ;;; ;;; ;;;;;;; 
;   ;;; ;;; ;; ;;;    ;;;;;;   ;;;;;    ;;;;;   ;;;   ;;; ;;;;;;   ;;;;;  
; here are some functions written in C used mainly to access hardware

(require scheme/foreign)
(unsafe!) ;imported functions may crash the app

(define door (ffi-lib "./libdoor"))

;opens the door (door/open fd seconds)
(define door/open
  (get-ffi-obj "door_open" door (_fun _int _int -> _int)))
;closes the door (door/close fd)
(define door/close
  (get-ffi-obj "door_close" door (_fun _int -> _int)))
;initializes serial interface (door/init devName)
(define door/init 
  (get-ffi-obj "serial_init" door (_fun _string  -> _int)))
;resets serial inteface
(define door/reset
  (get-ffi-obj "serial_reset" door (_fun _int _string -> _int)))
(define door/readln
  (get-ffi-obj "serial_readln_scheme" door (_fun _int -> _string)))
(define door/flush
  (get-ffi-obj "serial_flush" door (_fun _int -> _int)))


;some test functions: to be deleted
(define door/test
  (get-ffi-obj "door_test" door (_fun _int -> _int)))
(define door/str
  (get-ffi-obj "door_string" door (_fun _string _int -> _string)))

;                               ;;                  ;;;
;                              ;;;                  ;;;
;    ;;;;;    ;;;;;   ;; ;;;  ;;;;;; ;;;;;  ;;;;;   ;;;
;   ;;;;;;;  ;;;;;;;  ;;;;;;; ;;;;;  ;;;;; ;;;;;;;  ;;;
;   ;;   ;   ;;   ;;  ;;; ;;;  ;;;   ;;;   ;;   ;;  ;;;
;   ;;       ;;   ;;  ;;  ;;;  ;;;   ;;;   ;;   ;;  ;;;
;   ;;   ;;  ;;   ;;  ;;  ;;;  ;;;   ;;;   ;;   ;;  ;;;
;   ;;;;;;;  ;;;;;;;  ;;  ;;;  ;;;;  ;;;   ;;;;;;;  ;;;
;    ;;;;;    ;;;;;   ;;  ;;;   ;;;  ;;;    ;;;;;   ;;;
;                                                      
; functions that communicate with hardware. main function lurch opens the door.

(require scheme/date)
;TODO: try load, start! or something else. loading user hash table
(define conf (open-input-file "./users.ss"))
(define *users* (read conf))
(close-input-port conf)

(define (time-formatted)
  (let ([date (seconds->date (current-seconds))])
    (format "~a-~a-~a-~a:~a:~a" 
            (date-year date)
            (date-month date)
            (date-day date)
            (date-hour date)
            (date-minute date)
            (date-second date)
            )))

(define (current-hour)
  (let ([date (seconds->date (current-seconds))])
    (date-hour date)))

(define (current-day)
  (let ([date (seconds->date (current-seconds))])
    (date-week-day date)))
;range can be a cons denoting interval or a list of accepted values
(define (in-range range number)
  (cond
    [(and (list? range) (number? number)) (ormap (λ (x) (= x number)) range)]
    [(and (pair? range) (number? number)) (and (>= number (car range)) (<= number (cdr range)))]
    [else #f]))

(define (lurch fd) 
  (let ([message (thread-receive)]);this line will block and wait
    (if (regexp-match #rx"^RFID.*|WEB.*" message)
        (let ([reply (door/open fd 2)])
          (cond
            [(> reply 0) (log-warning (format "OPENED at ~a by ~a" (time-formatted) message))]
            [else (log-warning (format "\tERROR[~a] opening at ~a for ~a" reply (time-formatted) message))
                 ; (set! fd (door/reset fd devName)) ;on error reset the device
                  ])) 
        #f))  
  (lurch fd))
;                         ;;;                                                       
;                         ;;;                                                       
;  ;;;  ;;;  ;;;  ;;;;;   ;;;;;;        ;;;;    ;;;;;   ;;;;;;;;  ;;;  ;;;;;   ;;;;;
;   ;;  ;;;  ;;  ;;;;;;;  ;;;;;;;      ;; ;;;  ;;;;;;;  ;;;;; ;;  ;;; ;;;;;;;  ;;;;;
;   ;; ;;;; ;;;  ;;   ;;  ;;;  ;;      ;;;     ;;   ;;  ;;;   ;;; ;;  ;;   ;;  ;;;  
;   ;;;;;;;;;;  ;;;;;;;;; ;;;  ;;      ;;;;;; ;;;;;;;;; ;;;   ;;;;;; ;;;;;;;;; ;;;  
;    ;;;; ;;;;   ;;       ;;;  ;;          ;;; ;;       ;;;    ;;;;   ;;       ;;;  
;    ;;;  ;;;;   ;;;;;;;  ;;;;;;;      ;;; ;;; ;;;;;;;  ;;;    ;;;;   ;;;;;;;  ;;;  
;    ;;;   ;;     ;;;;;   ;; ;;;       ;;;;;;   ;;;;;   ;;;     ;;     ;;;;;   ;;;  


;TODO: ADD WEB SERVER CODE


;                                     
;                         ;;;         
;                         ;;          
;   ;; ;;;  ;;;   ;;;;;   ;;; ;; ;;;  
;   ;;;;;;;;;;;  ;;;;;;;  ;;; ;;;;;;; 
;   ;;; ;;;  ;;;     ;;;  ;;; ;;; ;;; 
;   ;;; ;;;  ;;;  ;;;;;;  ;;; ;;  ;;; 
;   ;;; ;;;  ;;; ;;;  ;;  ;;; ;;  ;;; 
;   ;;; ;;;  ;;; ;;; ;;;  ;;; ;;  ;;; 
;   ;;; ;;;  ;;; ;;;; ;;  ;;; ;;  ;;; 

(define (say-text message)
  (call-with-output-file "festival-say.txt" (λ (file) 
                                              (write `(SayText ,message) file)) #:exists 'append))

(define (RFID-authenticate-and-open read)
  (let ([user-data (hash-ref *users* read #f)])
    (if user-data
        (cond
          [(and 
            (in-range (caadr user-data) (current-hour)) 
            (in-range (cadadr user-data) (current-day))) (thread-send to-lurch (string-append "RFID: " (car user-data)))
                                                         (string-append "Welcome, " (car user-data) ".")]
          [else (string-append (car user-data) ", please try later!")])
        "Access denied!")))

(define (listener)
  (let ([textID (regexp-match #rx"^[0|1]+" (door/readln fd))])
    (cond
      [textID (say-text (RFID-authenticate-and-open (car textID))) (log-warning "ID read") (sleep 0.2)]
      [else #f]))
  (listener))
;                         ;;;          ;;;            ;;;;;;;                          
;                         ;;;          ;;;           ;;;; ;;                           
;    ;;;;;   ;; ;;;    ;;;;;;       ;;;;;;   ;;;;;  ;;;;; ;;; ;; ;;;    ;;;;;    ;;;;  
;   ;;;;;;;  ;;;;;;;  ;;;;;;;      ;;;;;;;  ;;;;;;; ;;;;; ;;; ;;;;;;;  ;;;;;;;  ;; ;;; 
;   ;;   ;;  ;;; ;;;  ;;  ;;;      ;;  ;;;  ;;   ;;  ;;;  ;;; ;;; ;;;  ;;   ;;  ;;;    
;  ;;;;;;;;; ;;  ;;; ;;;  ;;;     ;;;  ;;; ;;;;;;;;; ;;;  ;;; ;;  ;;; ;;;;;;;;; ;;;;;; 
;   ;;       ;;  ;;;  ;;  ;;;      ;;  ;;;  ;;       ;;;  ;;; ;;  ;;;  ;;           ;;;
;   ;;;;;;;  ;;  ;;;  ;;;;;;;      ;;;;;;;  ;;;;;;;  ;;;  ;;; ;;  ;;;  ;;;;;;;  ;;; ;;;
;    ;;;;;   ;;  ;;;   ;;;;;;       ;;;;;;   ;;;;;   ;;;  ;;; ;;  ;;;   ;;;;;   ;;;;;; 

(define devName "/dev/ttyS0")
(define fd (door/init devName))
;(define fd 1); from stdin 
(define to-lurch (thread (λ () (lurch fd))))
(listener)
  ;(say-text (RFID-authenticate-and-open "01"))
  
  